Celestin Apprentice 4/Apprentice-Release4.iso/Languages/Open Prolog 1.0.3d23/External Predicates…/Sources/SoundPlay.p

Text File | 1995-11-10 | 7.9 KB | 302 lines | [TEXT/MPS ]

{$D+} { MacsBug symbols on }
{$R-} { No range checking }

UNIT prlxsample;

  INTERFACE

    USES resources,sound,textUtils, prlxdefinitions;

    PROCEDURE entrypoint(plist: prlxptr);

  IMPLEMENTATION

    PROCEDURE main(plist: prlxptr);
      FORWARD;

    PROCEDURE entrypoint(plist: prlxptr);

      BEGIN
        main(plist);
      END;

    PROCEDURE main;

      VAR
        s: str255;
        i: integer;
        l, m: longint;

      PROCEDURE macsbug(VAR st: str255);
        INLINE $ABFF;

      PROCEDURE writestr(st: str255);

        BEGIN
          WITH plist^ DO
            BEGIN
            callbackrequest := writestring;
            s := st;
            callback(entrypoint);
            END;
        END;

      PROCEDURE writelnstr(st: str255);

        BEGIN
          WITH plist^ DO
            BEGIN
            callbackrequest := writelnstring;
            s := st;
            callback(entrypoint);
            END;
        END;

      PROCEDURE errorstr(st: str255);

        BEGIN
          WITH plist^ DO
            BEGIN
            callbackrequest := writeerror;
            s := st;
            callback(entrypoint);
            END;
        END;

      FUNCTION returnValue(termNumber: termIndex;
                           n: longint): boolean;

        BEGIN
          WITH plist^ DO
            BEGIN
            callbackrequest := unifyToInteger;
            callbackdata[1] := termnumber;
            callbackData[2] := n;
            callback(entrypoint);
            returnValue := callbackData[3] = messageOK;
            END;
        END;

      FUNCTION returnStructure(termNumber: termIndex;
                               st: str255;
                               arity: integer): boolean;

        BEGIN
          WITH plist^ DO
            BEGIN
            callbackrequest := unifyToFunctor;
            callbackdata[1] := termnumber;
            callbackData[3] := arity;
            s := st;
            callback(entrypoint);
            returnStructure := callbackData[3] = messageOK;
            END;
        END;

      FUNCTION returnAtom(termNumber: termIndex;
                          st: str255): boolean;

        BEGIN
          returnAtom := returnStructure(termNumber, st, 0);
        END;

      FUNCTION subterm(subtermordinate: integer;
                       termnumber: termindex): termindex;

        BEGIN
          WITH plist^ DO
            BEGIN
            callbackrequest := getsubterm;
            callbackdata[1] := termnumber;
            callbackdata[2] := subtermordinate;
            callback(entrypoint);
            subterm := callbackdata[3];
            END;
        END;

      FUNCTION number(termnumber: termindex): boolean;

        BEGIN
          WITH plist^ DO
            BEGIN
            callbackrequest := getterminfo;
            callbackdata[1] := termnumber;
            callback(entrypoint);
            number := (callbackdata[1] = integertag);
            END;
        END;

      FUNCTION atom(termnumber: termindex): boolean;

        BEGIN
          WITH plist^ DO
            BEGIN
            callbackrequest := getterminfo;
            callbackdata[1] := termnumber;
            callback(entrypoint);
            atom := (callbackdata[1] = atomtag);
            END;
        END;

      FUNCTION structure(termnumber: termindex): boolean;

        BEGIN
          WITH plist^ DO
            BEGIN
            callbackrequest := getterminfo;
            callbackdata[1] := termnumber;
            callback(entrypoint);
            structure := (callbackdata[1] = structuretag);
            END;
        END;

      FUNCTION variable(termnumber: termindex): boolean;

        BEGIN
          WITH plist^ DO
            BEGIN
            callbackrequest := getterminfo;
            callbackdata[1] := termnumber;
            callback(entrypoint);
            variable := (callbackdata[1] = variabletag);
            END;
        END;

      FUNCTION value(termnumber: termindex): longint;

        BEGIN
          WITH plist^ DO
            BEGIN
            callbackrequest := getterminfo;
            callbackdata[1] := termnumber;
            callback(entrypoint);
            IF callbackdata[1] = integertag THEN
              value := callbackdata[2]
            ELSE
              errorstr('attempt to get value of a non-integer');
            END;
        END;

      FUNCTION arity(termnumber: termindex): integer;

        BEGIN
          WITH plist^ DO
            BEGIN
            callbackrequest := getterminfo;
            callbackdata[1] := termnumber;
            callback(entrypoint);
            CASE callbackdata[1] OF
              atomtag, integertag, variabletag: arity := 0;
              structuretag: arity := callbackdata[2];
              OTHERWISE errorstr('Funny data from getTermInfo in arity');
            END;
            END;
        END;

      FUNCTION text(termnumber: termindex): str255;

        VAR
          st: str255;
          i: integer;

        BEGIN
          WITH plist^ DO
            BEGIN
            callbackrequest := getterminfo;
            callbackdata[1] := termnumber;
            callback(entrypoint);
            CASE callbackdata[1] OF
              atomtag, structuretag: text := s;
              integertag:
                BEGIN
                numtostring(callbackdata[2], st);
                text := st;
                END;
              variabletag:
                BEGIN
                numtostring(callbackdata[2], st);
                FOR i := 255 DOWNTO 2 DO st[i] := st[i - 1];
                st[1] := '_';
                text := st;
                END;
              OTHERWISE errorstr('Funny data from getTermInfo in text');
            END;
            END;
        END;

      PROCEDURE play;

        VAR
          result: osErr;
          theChannel: sndChannelPtr;
          theSnd: handle;
          level: integer;
          total, contig: longint;
          soundName: str255;

        BEGIN
          plist^.successful := false;
          plist^.determinate := true;
          theChannel := NIL;
          soundName := text(1); {do this before purgeSpace to ensure runtime
                                 stuff is included }
          purgeSpace(total, contig);
          setResLoad(false);
          theSnd := getnamedResource('snd ', soundName);
          setResLoad(true);
          IF resError = noErr THEN
            IF sizeResource(theSnd) + 2 * 1024 < contig THEN
              BEGIN
              getSoundVol(level);
              IF value(2) <> 0 THEN setSoundVol(value(2));
              loadResource(theSnd);
              hNoPurge(theSnd);
              IF resError = noErr THEN
                plist^.successful := (sndPlay(NIL, sndListHandle(theSnd), true) = noErr);
              hPurge(theSnd); {don't dispose of it - you might use it again!}
              setSoundVol(level);
              END;

        END; { procedure }

      BEGIN
        WITH plist^ DO
          BEGIN
          CASE request OF
            getPRLXInfo:
                        begin
                        data[1] := 1; {number of predicates defined}
                        data[2]:=eventsVersion;
                        end;
            initialisepredicate:
              CASE id OF
                1: {play/2}
                  BEGIN
                  s := 'play'; {name}
                  data[1] := 2; {arity}
                  data[2] := 0; {permanent data}
                  END;
                OTHERWISE
                  errorstr('predicate index out of range at initialise');
              END;
            callpredicate:
              BEGIN
              successful := true;
              CASE id OF
                1: play;
                OTHERWISE errorstr('predicate index out of range at call');
              END;
              END;
            closepredicate:
              BEGIN
              CASE id OF
                1: {play} ;
                OTHERWISE errorstr('predicate index out of range at close');
              END;
              END;
            OTHERWISE errorstr('unknown call to external procedures');
          END;
          END;
      END;
END.